home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xscheme.arc / xsfun1.c < prev    next >
C/C++ Source or Header  |  1989-01-29  |  20KB  |  1,020 lines
  1. /* xsfun1.c - xscheme built-in functions - part 1 */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* gensym variables */
  9. static char gsprefix[STRMAX+1] = { 'G',0 };    /* gensym prefix string */
  10. static int gsnumber = 1;            /* gensym number */
  11.  
  12. /* external variables */
  13. extern LVAL xlenv,xlval,default_object,true;
  14. extern LVAL s_unbound;
  15.  
  16. /* external routines */
  17. extern int eq(),eqv(),equal();
  18.  
  19. /* forward declarations */
  20. FORWARD LVAL cxr();
  21. FORWARD LVAL member();
  22. FORWARD LVAL assoc();
  23. FORWARD LVAL nth();
  24. FORWARD LVAL eqtest();
  25.  
  26. /* xcons - construct a new list cell */
  27. LVAL xcons()
  28. {
  29.     LVAL carval,cdrval;
  30.     
  31.     /* get the two arguments */
  32.     carval = xlgetarg();
  33.     cdrval = xlgetarg();
  34.     xllastarg();
  35.  
  36.     /* construct a new cons node */
  37.     return (cons(carval,cdrval));
  38. }
  39.  
  40. /* xcar - built-in function 'car' */
  41. LVAL xcar()
  42. {
  43.     LVAL list;
  44.     list = xlgalist();
  45.     xllastarg();
  46.     return (list ? car(list) : NIL);
  47. }
  48.  
  49. /* xicar - built-in function '%car' */
  50. LVAL xicar()
  51. {
  52.     LVAL cons;
  53.     cons = xlgetarg();
  54.     xllastarg();
  55.     return (car(cons));
  56. }
  57.  
  58. /* xcdr - built-in function 'cdr' */
  59. LVAL xcdr()
  60. {
  61.     LVAL list;
  62.     list = xlgalist();
  63.     xllastarg();
  64.     return (list ? cdr(list) : NIL);
  65. }
  66.  
  67. /* xicdr - built-in function '%cdr' */
  68. LVAL xicdr()
  69. {
  70.     LVAL cons;
  71.     cons = xlgetarg();
  72.     xllastarg();
  73.     return (cdr(cons));
  74. }
  75.  
  76. /* cxxr functions */
  77. LVAL xcaar() { return (cxr("aa")); }
  78. LVAL xcadr() { return (cxr("da")); }
  79. LVAL xcdar() { return (cxr("ad")); }
  80. LVAL xcddr() { return (cxr("dd")); }
  81.  
  82. /* cxxxr functions */
  83. LVAL xcaaar() { return (cxr("aaa")); }
  84. LVAL xcaadr() { return (cxr("daa")); }
  85. LVAL xcadar() { return (cxr("ada")); }
  86. LVAL xcaddr() { return (cxr("dda")); }
  87. LVAL xcdaar() { return (cxr("aad")); }
  88. LVAL xcdadr() { return (cxr("dad")); }
  89. LVAL xcddar() { return (cxr("add")); }
  90. LVAL xcdddr() { return (cxr("ddd")); }
  91.  
  92. /* cxxxxr functions */
  93. LVAL xcaaaar() { return (cxr("aaaa")); }
  94. LVAL xcaaadr() { return (cxr("daaa")); }
  95. LVAL xcaadar() { return (cxr("adaa")); }
  96. LVAL xcaaddr() { return (cxr("ddaa")); }
  97. LVAL xcadaar() { return (cxr("aada")); }
  98. LVAL xcadadr() { return (cxr("dada")); }
  99. LVAL xcaddar() { return (cxr("adda")); }
  100. LVAL xcadddr() { return (cxr("ddda")); }
  101. LVAL xcdaaar() { return (cxr("aaad")); }
  102. LVAL xcdaadr() { return (cxr("daad")); }
  103. LVAL xcdadar() { return (cxr("adad")); }
  104. LVAL xcdaddr() { return (cxr("ddad")); }
  105. LVAL xcddaar() { return (cxr("aadd")); }
  106. LVAL xcddadr() { return (cxr("dadd")); }
  107. LVAL xcdddar() { return (cxr("addd")); }
  108. LVAL xcddddr() { return (cxr("dddd")); }
  109.  
  110. /* cxr - common car/cdr routine */
  111. LOCAL LVAL cxr(adstr)
  112.   char *adstr;
  113. {
  114.     LVAL list;
  115.  
  116.     /* get the list */
  117.     list = xlgalist();
  118.     xllastarg();
  119.  
  120.     /* perform the car/cdr operations */
  121.     while (*adstr && consp(list))
  122.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  123.  
  124.     /* make sure the operation succeeded */
  125.     if (*adstr && list)
  126.     xlbadtype(list);
  127.  
  128.     /* return the result */
  129.     return (list);
  130. }
  131.  
  132. /* xsetcar - built-in function 'set-car!' */
  133. LVAL xsetcar()
  134. {
  135.     LVAL arg,newcar;
  136.  
  137.     /* get the cons and the new car */
  138.     arg = xlgacons();
  139.     newcar = xlgetarg();
  140.     xllastarg();
  141.  
  142.     /* replace the car */
  143.     rplaca(arg,newcar);
  144.     return (arg);
  145. }
  146.  
  147. /* xisetcar - built-in function '%set-car!' */
  148. LVAL xisetcar()
  149. {
  150.     LVAL arg,newcar;
  151.  
  152.     /* get the cons and the new car */
  153.     arg = xlgetarg();
  154.     newcar = xlgetarg();
  155.     xllastarg();
  156.  
  157.     /* replace the car */
  158.     rplaca(arg,newcar);
  159.     return (arg);
  160. }
  161.  
  162. /* xsetcdr - built-in function 'set-cdr!' */
  163. LVAL xsetcdr()
  164. {
  165.     LVAL arg,newcdr;
  166.  
  167.     /* get the cons and the new cdr */
  168.     arg = xlgacons();
  169.     newcdr = xlgetarg();
  170.     xllastarg();
  171.  
  172.     /* replace the cdr */
  173.     rplacd(arg,newcdr);
  174.     return (arg);
  175. }
  176.  
  177. /* xisetcdr - built-in function '%set-cdr!' */
  178. LVAL xisetcdr()
  179. {
  180.     LVAL arg,newcdr;
  181.  
  182.     /* get the cons and the new cdr */
  183.     arg = xlgetarg();
  184.     newcdr = xlgetarg();
  185.     xllastarg();
  186.  
  187.     /* replace the cdr */
  188.     rplacd(arg,newcdr);
  189.     return (arg);
  190. }
  191.  
  192. /* xlist - built-in function 'list' */
  193. LVAL xlist()
  194. {
  195.     LVAL last,next,val;
  196.  
  197.     /* initialize the list */
  198.     val = NIL;
  199.  
  200.     /* add each argument to the list */
  201.     if (moreargs()) {
  202.         val = last = cons(nextarg(),NIL);
  203.         while (moreargs()) {
  204.         next = nextarg();
  205.         push(val);
  206.         next = cons(next,NIL);
  207.         rplacd(last,next);
  208.         last = next;
  209.         val = pop();
  210.     }
  211.     }
  212.  
  213.     /* return the list */
  214.     return (val);
  215. }
  216.  
  217. /* xappend - built-in function 'append' */
  218. LVAL xappend()
  219. {
  220.     LVAL next,this,last,val;
  221.  
  222.     /* append each argument */
  223.     for (val = last = NIL; xlargc > 1; )
  224.  
  225.     /* append each element of this list to the result list */
  226.     for (next = xlgalist(); consp(next); next = cdr(next)) {
  227.         push(val);
  228.         this = cons(car(next),NIL);
  229.         val = pop();
  230.         if (last == NIL) val = this;
  231.         else rplacd(last,this);
  232.         last = this;
  233.     }
  234.  
  235.     /* tack on the last argument */
  236.     if (moreargs()) {
  237.     if (last == NIL) val = xlgetarg();
  238.     else rplacd(last,xlgetarg());
  239.     }
  240.  
  241.     /* return the list */
  242.     return (val);
  243. }
  244.  
  245. /* xreverse - built-in function 'reverse' */
  246. LVAL xreverse()
  247. {
  248.     LVAL next,val;
  249.     
  250.     /* get the list to reverse */
  251.     next = xlgalist();
  252.     xllastarg();
  253.  
  254.     /* append each element of this list to the result list */
  255.     for (val = NIL; consp(next); next = cdr(next)) {
  256.     push(val);
  257.     val = cons(car(next),top());
  258.     drop(1);
  259.     }
  260.  
  261.     /* return the list */
  262.     return (val);
  263. }
  264.  
  265. /* xlastpair - built-in function 'last-pair' */
  266. LVAL xlastpair()
  267. {
  268.     LVAL list;
  269.  
  270.     /* get the list */
  271.     list = xlgalist();
  272.     xllastarg();
  273.  
  274.     /* find the last cons */
  275.     if (consp(list))
  276.     while (consp(cdr(list)))
  277.         list = cdr(list);
  278.  
  279.     /* return the last element */
  280.     return (list);
  281. }
  282.  
  283. /* xlength - built-in function 'length' */
  284. LVAL xlength()
  285. {
  286.     FIXTYPE n;
  287.     LVAL arg;
  288.  
  289.     /* get the argument */
  290.     arg = xlgalist();
  291.     xllastarg();
  292.  
  293.     /* find the length */
  294.     for (n = (FIXTYPE)0; consp(arg); ++n)
  295.     arg = cdr(arg);
  296.  
  297.     /* return the length */
  298.     return (cvfixnum(n));
  299. }
  300.  
  301. /* xmember - built-in function 'member' */
  302. LVAL xmember()
  303. {
  304.     return (member(equal));
  305. }
  306.  
  307. /* xmemv - built-in function 'memv' */
  308. LVAL xmemv()
  309. {
  310.     return (member(eqv));
  311. }
  312.  
  313. /* xmemq - built-in function 'memq' */
  314. LVAL xmemq()
  315. {
  316.     return (member(eq));
  317. }
  318.  
  319. /* member - common routine for member/memv/memq */
  320. LOCAL LVAL member(fcn)
  321.   int (*fcn)();
  322. {
  323.     LVAL x,list,val;
  324.  
  325.     /* get the expression to look for and the list */
  326.     x = xlgetarg();
  327.     list = xlgalist();
  328.     xllastarg();
  329.  
  330.     /* look for the expression */
  331.     for (val = NIL; consp(list); list = cdr(list))
  332.     if ((*fcn)(x,car(list))) {
  333.         val = list;
  334.         break;
  335.     }
  336.  
  337.     /* return the result */
  338.     return (val);
  339. }
  340.  
  341. /* xassoc - built-in function 'assoc' */
  342. LVAL xassoc()
  343. {
  344.     return (assoc(equal));
  345. }
  346.  
  347. /* xassv - built-in function 'assv' */
  348. LVAL xassv()
  349. {
  350.     return (assoc(eqv));
  351. }
  352.  
  353. /* xassq - built-in function 'assq' */
  354. LVAL xassq()
  355. {
  356.     return (assoc(eq));
  357. }
  358.  
  359. /* assoc - common routine for assoc/assv/assq */
  360. LOCAL LVAL assoc(fcn)
  361.   int (*fcn)();
  362. {
  363.     LVAL x,alist,pair,val;
  364.  
  365.     /* get the expression to look for and the association list */
  366.     x = xlgetarg();
  367.     alist = xlgalist();
  368.     xllastarg();
  369.  
  370.     /* look for the expression */
  371.     for (val = NIL; consp(alist); alist = cdr(alist))
  372.     if ((pair = car(alist)) && consp(pair))
  373.         if ((*fcn)(x,car(pair),fcn)) {
  374.         val = pair;
  375.         break;
  376.         }
  377.  
  378.     /* return the result */
  379.     return (val);
  380. }
  381.  
  382. /* xlistref - built-in function 'list-ref' */
  383. LVAL xlistref()
  384. {
  385.     return (nth(TRUE));
  386. }
  387.  
  388. /* xlisttail - built-in function 'list-tail' */
  389. LVAL xlisttail()
  390. {
  391.     return (nth(FALSE));
  392. }
  393.  
  394. /* nth - internal nth function */
  395. LOCAL LVAL nth(carflag)
  396.   int carflag;
  397. {
  398.     LVAL list,arg;
  399.     int n;
  400.  
  401.     /* get n and the list */
  402.     list = xlgalist();
  403.     arg = xlgafixnum();
  404.     xllastarg();
  405.  
  406.     /* range check the index */
  407.     if ((n = (int)getfixnum(arg)) < 0)
  408.     xlerror("index out of range",arg);
  409.  
  410.     /* find the nth element */
  411.     for (; consp(list) && n; n--)
  412.     list = cdr(list);
  413.  
  414.     /* make sure the list was long enough */
  415.     if (n)
  416.